home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / cg-regs < prev    next >
Text File  |  1998-05-20  |  48KB  |  2,031 lines
  1. marker m__cg-regs
  2.  
  3. PPC?
  4. [IF]
  5. false    constant    debug?
  6. false    constant    recompTest?
  7. [ELSE]
  8. false    constant    debug?
  9. false    constant    recompTest?
  10. [THEN]
  11.  
  12.  
  13. (* This file defines the classes we use to describe the PPC registers,
  14.    and creates the register objects.
  15. *)
  16.  
  17. 3        constant    spill_cnt        ¥ the number of regs we spill if we can't
  18.                                     ¥  otherwise get a free one
  19.  
  20. 0    value    #gprs_cleared            ¥ used by the spilling code, to count
  21.                                     ¥  the GPRs we actually free up
  22.  
  23. ¥ Some useful boilerplate instructions:
  24.  
  25. PPC?
  26. [IF]        ¥ In this case these are already defined
  27.             ¥  in the 68k image, and we can't interpret the << ops,
  28.             ¥  so we'll do it this way:
  29.             
  30.     LR>R0        constant    LR>R0        ¥ mflr  r0
  31.     R0>LR        constant    R0>LR        ¥ mtlr  r0
  32.     BLR            constant    BLR            ¥ unconditional branch to link reg
  33.  
  34. [ELSE]
  35.  
  36.     31 26 <<
  37.     8  16 << or
  38.     339 1 << or        constant    LR>R0    ¥ mflr  r0
  39.     
  40.     31 26 <<
  41.     8  16 << or
  42.     467 1 << or        constant    R0>LR    ¥ mtlr  r0
  43.  
  44.     19 26 <<
  45.   $ 14 21 <<  or
  46.     16  1 <<  or    constant    BLR        ¥ unconditional branch to link reg
  47.  
  48. [THEN]
  49.  
  50. : GPR>CTR  ( reg# -- )  21 <<  $ 7C0903A6 or  code,  ;
  51. : CTR>GPR  ( reg# -- )  21 <<  $ 7C0902A6 or  code,  ;
  52.  
  53. : nop,  ( -- )  $ 7C000378  code,  ;        ¥ or  r0, r0, r0
  54.  
  55.  
  56. forward  SPILL
  57. forward  check_for_moved_stores
  58.  
  59.  
  60. :class  REFERENCE_LIST  super{ reference obj_array }
  61.  
  62.     int    SIZE
  63.     
  64. :m SIZE:    inline{ get: size}    get: size  ;m
  65. :m >SiZE:    inline{ put: size}    put: size  ;m
  66. :m +SIZE:    inline{ +: size}    +: size    ;m
  67.  
  68. :m STK:  { n ¥ index -- }
  69.             ¥ Using self as a stack, selects the n'th
  70.             ¥  cell.  We don't report an error if n is greater than the
  71.             ¥  current depth, since there are situations in equalizing over
  72.             ¥  basic blocks where it would be a big pest to check all the time.
  73.             ¥  We just make sure such out-of-range cells return "noRef" type.
  74.  
  75.     ASSERT{ n 0> }        ¥ error if stk: called with a neg or zero index
  76.     get: size  n -  -> index
  77.     index 0<
  78.     IF    limit 1- select: self
  79.         noRef >refType: self
  80.     ELSE
  81.         index  select: self
  82.     THEN
  83. ;m
  84.  
  85. :m PUSH:    ¥ ( ^ref -- )
  86.     get: size  select: self
  87.     ->: self
  88.     1 +: size
  89. ;m
  90.  
  91. :m MOVEDOWN:        ¥ moves all items "down" to make room for another.
  92.                     ¥  Leaves element zero selected.
  93.     get: size
  94.     IF    get: size
  95.         FOR    i ^elem
  96.             i 1+ select: self
  97.             ->: self
  98.         NEXT
  99.     THEN
  100.     1 +: size
  101.     0 select: self
  102. ;m
  103.  
  104. :m MOVEUP:
  105.     get: size  NIF ." moveup: finds zero size" cr
  106.                     printall: self  ( 1 die )
  107.                THEN
  108.  
  109.     0 select: self  free: self        ¥ note - reg is now selected
  110.     
  111.     get: refType
  112.     SELECT[ gprRef ]=>    ?clear_GPR
  113.           [ crRef  ]=>    ?clear_CR
  114.  
  115.         DEFAULT=>        drop    ¥ not an error - just nothing to do
  116.     ]SELECT
  117.  
  118.     1 -: size
  119.     get: size  0
  120.     ?DO    i 1+ ^elem
  121.         i select: self
  122.         ->: self
  123.     LOOP
  124. ;m
  125.  
  126. :m SAVE:
  127.     get: size  0 
  128.     ?DO  i select: self  stack: self  LOOP
  129.     get: size
  130. ;m
  131.  
  132. :m RESTORE:
  133.     dup  put: size  ?dup 0EXIT
  134.     FOR  i select: self  unstack: self  NEXT
  135. ;m
  136.  
  137. :m PRINTALL:
  138.     ." depth: "  get: size .  cr
  139.     get: size 0<
  140.     IF    clear: size  EXIT  THEN
  141.     get: size  0EXIT
  142.     get: current
  143.     get: size
  144.     FOR  ?pause  i select: self  print: self  NEXT
  145.     select: self
  146. ;m
  147.  
  148. ;class
  149.  
  150.  
  151. 24    reference_list    CSTK        ¥ Compile time stack - maps the run-time
  152.                                 ¥ data stack to regs
  153.  
  154. 24    reference_list    CSTK2        ¥ Used in equalizing between basic blocks
  155. 24    reference_list    CSTK2_ORIG    ¥ Ditto
  156.  
  157. 24    reference_list    CSTK_TEMP    ¥ For scratch while equalizing
  158.  
  159. 24    reference_list    FCSTK        ¥ Floating compile time stack
  160.  
  161. 24    reference_list    FCSTK2
  162. 24    reference_list    FCSTK2_ORIG
  163.  
  164. 24    reference_list    FCSTK_TEMP
  165.  
  166.  
  167. objPtr    aRef    class_is reference
  168. objPtr    aRef2    class_is reference
  169.  
  170. objPtr    aRefL    class_is reference_list
  171.  
  172.  
  173. (*    ODs_CLASS is an array of OD objects, defined using obj_array.
  174.     We'll use this class for our 3 register files - GPRs, FPRs and CRs.
  175. *)
  176.  
  177.  
  178. :class    ODs_CLASS  super{ OD large_obj_array }
  179.  
  180. objPtr    spillODs  class_is ODs_class
  181.  
  182.     int        last_allocated
  183.     int        alloc_limit        ¥ last reg# we can allocate
  184.  
  185.  
  186. :m LAST_ALLOCATED:        get: last_allocated  ;m
  187. :m >LAST_ALLOCATED:        put: last_allocated  ;m
  188.  
  189. :m >ALLOC_LIMIT:        put: alloc_limit    ;m
  190.  
  191. private
  192.  
  193. (* We call is_reg_unused?: in the first loop while trying to find a free
  194.    reg.  An "unused" reg is preferable to one with a zero refCnt, since
  195.    the latter could still hold a valid value that could be reused in
  196.    future, or may have just recently been used and so not be avaliable
  197.    for retargetting an earlier op.
  198.    Factoring out this method allows us to tinker with it a bit.
  199. *)
  200.  
  201. :m is_reg_unused?:  ( -- b )
  202.  
  203.     (* First we can only grab a reg if its refCnt is zero.  If it's
  204.        nonzero, the reg is live, so we can't use it no matter what.
  205.        (This also allows us to block a particular reg being allocated,
  206.        even if it's empty, by setting its refcnt nonzero.  We need to
  207.        do this for CR0 in particular.
  208.     *)
  209.     get: refCnt IF  false  EXIT  THEN
  210.     
  211.     (* Now we look for a completely unused reg, or one with type
  212.        otUnknown and lastRefCDP at or before the current basic block
  213.        start.  That's just as good, as it could never be reused, and
  214.        could never block a retargetting.
  215.     *)
  216.     get: opType  NIF  true  EXIT  THEN
  217.     get: opType  otUnknownCodes >  IF  false  EXIT  THEN
  218.  
  219.     get: lastRefCDP  basic_block_start u<=
  220.     IF
  221.         get: opCDP  basic_block_start u>
  222.         IF
  223.             get: opCDP  put: lastRefCDP
  224.         THEN
  225.         true  EXIT
  226.     THEN
  227.     false
  228. ;m
  229.  
  230. public
  231.  
  232. (*    GetFreeReg: does just that.  We first try to find a completely unused
  233.     reg.  If that fails, we can do one of two things - we can grab a reg
  234.     which is inactive (zero refcnt) but with a valid value, or we
  235.     can spill some of the stack to memory which will free active
  236.     regs.  We used to try to keep at least 3 recently computed
  237.     values, and so spilled if there were 3 or less inactive regs.
  238.     But this was disastrous if we were doing an equalization, and
  239.     anyway a spill should probably be a last resort thing anyway.
  240.     So now we only spill if we're right out of regs.
  241.     
  242.     Note, that one thing that's tempting to do is call update_refcnts
  243.     in case there's a reg that's apparently referenced but really isn't.
  244.     This can happen.  But it's not safe to call update_refcnts here, since
  245.     we can be in the middle of doing just about anything when we need a
  246.     free reg.  We might have grabbed an operand or two into opnd1, opnd2
  247.     or res1, and no longer have a reference in cstk, which would lead
  248.     to us grabbing a reg that's in use.  We must only call update_refcnts
  249.     at places where we know it's safe.  So if we end up spilling regs when
  250.     one was really free already, that's just bad luck.
  251. *)
  252.  
  253.  
  254. :m GETFREEREG:  { ¥ found? reg# #inActive earliestInactive inactiveCDP
  255.                     spilled? -- reg# }
  256.  
  257.     false -> found?  false -> spilled?
  258.     0 -> #inActive  0 -> earliestInactive  -1 -> inactiveCDP
  259.  
  260.     BEGIN            ¥ will loop if there are no free regs and we have to spill
  261.  
  262.     ¥ first we try to find a completely unused reg:
  263.         get: alloc_limit 1+ 0
  264.         DO    i select: self
  265.             is_reg_unused?: self
  266.             IF
  267.                 debug? if
  268.                     ." allocating empty reg " i . cr
  269.                 then
  270.                 clear: self  allocate: self
  271.                 i  UNLOOP  EXIT
  272.             THEN
  273.             get: refCnt
  274.             NIF    1 ++> #inActive
  275.                 get: lastRefCDP inactiveCDP u<
  276.                 IF    get: lastRefCDP -> inactiveCDP
  277.                     i -> earliestInactive
  278.                 THEN
  279.             THEN
  280.         LOOP
  281.  
  282. ¥ not found yet.  We now look for an inactive reg.
  283.         #inactive 0>
  284.         IF
  285.             earliestInactive select: self
  286.             debug? if
  287.                 ." allocating inactive reg " print: myRef cr
  288.             then
  289.             clear: self  allocate: self
  290.             earliestInactive  EXIT
  291.         THEN
  292.         
  293. ¥ still none found.  We now spill to free up some regs.  If we've
  294. ¥  already spilled, we've got problems.  Hopefully this shouldn't
  295. ¥  happen.
  296.  
  297.         spilled? NIF  self -> spillODs  spill  ELSE  211 die  THEN
  298.  
  299.     AGAIN
  300. ;m
  301.  
  302.  
  303. :m ALLOCATE_REG:    ¥ ( reg# -- )
  304.     select: self  allocate: self  ;m
  305.  
  306. :m FREE_REG:        ¥ ( reg# -- )
  307.     select: self  free: self  ;m
  308.  
  309. :m ?DELETE_REG:        ¥ ( reg# -- )
  310.     select: self  ?delete: self  ;m
  311.  
  312.  
  313. :m MATCH?:  { ^OD canBeSpecial? ¥ svCurrent -- b }
  314.     get: current -> svCurrent
  315.     limit 0
  316.     DO    i select: self
  317.         get: special?
  318.         IF        canBeSpecial?
  319.         ELSE    true
  320.         THEN
  321.         IF    ^OD  =?: self
  322.             IF          ¥ equal, but need to check limit on validity
  323.                 CDP  get: validTillCDP  u<
  324.                 IF  unloop  true
  325.                     debug? if
  326.                         ." match?: matched on this reg: " print: myRef cr
  327.                     then
  328.                     EXIT
  329.                 THEN
  330.             THEN
  331.         THEN
  332.     LOOP
  333.     svCurrent  select: self
  334.     false
  335. ;m
  336.  
  337.  
  338. :m clearAll:
  339.     limit 0
  340.     DO    i select: self  full_clear: self
  341.         -1 put: last_allocated
  342.     LOOP
  343. ;m
  344.  
  345. :m clearAllWithBoundary:  { bdry -- }
  346.         ¥ called when we don't want a full clear on the non-volatile regs.
  347.     limit 0
  348.     DO    i select: self
  349.         i bdry < IF  full_clear: self  ELSE  clear: self  THEN
  350.         -1 put: last_allocated
  351.     LOOP
  352. ;m
  353.  
  354. :m INVALIDATE_ALL:        ¥ when we just need to invalidate, not completely clear
  355.     limit 0
  356.     DO    i select: self  clear: opType
  357.     LOOP
  358. ;m
  359.  
  360.  
  361. :m CLEAR_REFCNTS:        ¥ called from update_refcnts - see comment there.
  362.     get: current
  363.     get: alloc_limit 0
  364.     DO    i select: self  clear: refCnt
  365.     LOOP
  366.     select: self
  367. ;m
  368.  
  369.  
  370. ¥ UPDATE_ALL_REFS: replaces all occurrences of oldRef by newRef in
  371. ¥ the OD array.  Used when we've moved a register.
  372.  
  373. :m UPDATE_ALL_REFS:  { ^oldRef ^newRef fromCDP -- }
  374.     get: current
  375.     limit 0
  376.     DO    i select: self  ^oldRef ^newRef fromCDP  update_refs: self
  377.     LOOP
  378.     select: self
  379. ;m
  380.  
  381. ¥ REG_CHANGED: looks after the situation where a reg is getting changed,
  382. ¥ so for any regs which depend on the changed reg, we need to set its
  383. ¥ validTillCDP ivar to the current CDP.
  384.  
  385. :m REG_CHANGED:  { ^ref -- }
  386.     get: current
  387.     limit 0
  388.     DO    i select: self  ^ref ?antecedent_changed: self
  389.     LOOP
  390.     select: self
  391. ;m
  392.  
  393.  
  394. :m INVALIDATE_ON_OVERLAP:  { ^OD ¥ svCurrent -- }
  395.     get: current -> svCurrent
  396.     limit 0
  397.     DO    i select: self
  398.         ^OD  overlap?: self
  399.         IF          ¥ overlaps, but need to check limit on validity
  400.             CDP  get: validTillCDP  u<
  401.             IF
  402.                 debug? if
  403.                     blit: self  .h  ^OD blit: class_as> OD .h cr
  404.                     ." overlap?: matched on this reg: " print: self cr
  405.                     ." overlapping OD: "  print: [ ^OD ] cr
  406.                 then
  407.  
  408.                 CDP 4-  put: validTillCDP
  409.                 otUnknown  put: opType
  410.                 noType       put: instrnType
  411.                 addr: myRef  reg_changed: self
  412.             THEN
  413.         THEN
  414.     LOOP
  415.     svCurrent  select: self
  416. ;m
  417.  
  418.  
  419. :m UPDATE_opCDPs:
  420.     get: current
  421.     limit 0
  422.     DO    i select: self  update_opCDP: self
  423.     LOOP
  424.     select: self
  425. ;m
  426.  
  427. :m MAKE_ALTERED_REGS_UNKNOWN:
  428.     get: current
  429.     limit 0
  430.     DO    i select: self  make_unknown_if_altered: self
  431.     LOOP
  432.     select: self
  433. ;m
  434.  
  435.  
  436. :m MAKE_FETCHES_UNKNOWN:
  437.     get: current
  438.     limit 0
  439.     DO    i select: self  make_unknown_if_fetch: self
  440.     LOOP
  441.     select: self
  442. ;m
  443.  
  444.  
  445. :m ?HOIST_ALL:
  446.     get: current
  447.     limit 1
  448.     DO    i select: self  ?hoist: self  drop
  449.     LOOP
  450.     select: self
  451. ;m
  452.  
  453.  
  454. (* MOVEREG: moves an operand from one reg to a different one - we might have
  455.    to do this when equalizing the stack, for example.  If possible we just
  456.    recompile the operation that generated the original result, to generate it
  457.    straight in the new reg.  If all else fails we'll actually compile an
  458.    instruction to move the operand.
  459.    We leave the destination register selected.
  460. *)
  461.  
  462.  
  463. :m REG_MOVED:  { old# recompiled? -- }
  464.             ¥ housekeeping routine called after a move.  The new reg is currently
  465.             ¥ selected.  We update references and clear the old reg.
  466.  
  467.     debug? if
  468.         ." reg_moved: called - dest:" print: self
  469.     then
  470.     
  471.     addr: myRef  dup  ->: tmpRef1  ->: tmpRef2  old# >reg: tmpRef1
  472.     tmpRef1 tmpRef2  get: opCDP 4+
  473.     current: self  old# select: self
  474.     clear: super
  475.     recompiled?
  476.     IF        ref_gone: self
  477.     ELSE    CDP 4- put: lastRefCDP
  478.     THEN
  479.     select: self
  480.     update_refs
  481. ;m
  482.  
  483.  
  484. :m MOVEREG_BY_RECOMPILING?:  { old# new# ¥ qqq -- recompile? }
  485.     old# select: self
  486.     addr: self  copyOD: theOD    ¥ move old operand into theOD for convenience
  487.                                 ¥  need ALL ivars unchanged in this move
  488.     new# select: self
  489.  
  490.     recompTest? if
  491.         ." movereg_by_recompiling?" cr
  492.         ." eq_block_recompiling_move? "    eq_block_recompiling_move? . cr
  493.         ." source reg in theOD:"    print: theOD cr
  494.         ." dest reg:           "    print: self  cr
  495.         ." backstop_CDP        "    backstop_CDP .h cr
  496.         ." basic_block_start:  "    basic_block_start .h cr
  497.         ." lastRefCDP in dest  "    get: lastRefCDP .h cr
  498.     then
  499.  
  500.     false
  501.  
  502. ¥ Now we decide if we can handle a move by just recompiling the op.  There are
  503. ¥  several things to check.  Note we don't check fetch_backstop, since when we
  504. ¥  recompile an op we don't move it, so we can assume any fetches are valid
  505. ¥  in their existing location.  fetch_backstop only limits where we can
  506. ¥  move NEW fetches back to.
  507.  
  508.     recompTest?
  509.     if
  510.         [ ppc? ] [if] dbgr [then]
  511.     then
  512.  
  513.     move_by_recompiling?        0EXIT
  514.                         ¥ for debugging or whatever, we can turn this
  515.                         ¥  optimization off
  516.     
  517.     eq_block_recompiling_move?  ?EXIT
  518.                         ¥ if back equalizing, we're doing low-level things
  519.                         ¥  with regs and mustn't try to change anything.
  520.  
  521. ¥    get: ivar> opType    in theOD  otStore =
  522. ¥    [ ppc? not ] [if] dup if db then [then]  ?EXIT        ¥ shouldn't happen!!
  523. ¥                        ¥ stores can't be recompiled, since we've wiped out
  524. ¥                        ¥  the info on what we're storing.
  525.  
  526.     get: ivar> special? in theOD  ?EXIT
  527.                         ¥ can't recompile if the old reg is a local or
  528.                         ¥  base reg or whatever (which can't move)
  529.  
  530.     get: ivar> opType in theOD  otUnknownCodes <=  ?EXIT
  531.                         ¥ or if the old reg is empty or of unknown type
  532.                         ¥  (i.e. nothing to recompile)
  533.  
  534.     get: ivar> opCDP in theOD  basic_block_start    u<  ?EXIT
  535.                         ¥ or if its op wasn't in the current basic blk
  536.     
  537.     get: ivar> opCDP in theOD   backstop_CDP        u<  ?EXIT
  538.                         ¥ or if it would be past the backstop
  539.                         
  540. ¥    get: ivar> opType in theOD  otFetch =
  541. ¥    IF    get: ivar> opCDP in theOD  fetch_backstop    u<  ?EXIT  THEN
  542. ¥                        ¥ or the fetch backstop, if it's a fetch
  543.  
  544.     get: lastRefCDP  get: ivar> opCDP in theOD  u>  ?EXIT
  545.                         ¥ or if the last ref to the NEW reg was after the op
  546.                         ¥  we want to recompile, since we'd clobber that use.
  547.                         ¥ note we use >, not >=, since it's OK if the instrn
  548.                         ¥  we're recompiling uses its own reg as an operand.
  549.  
  550. ¥ if we got here, it's OK to recompile the op!
  551.  
  552.     drop                ¥ drop false flag
  553.  
  554.     recompTest? if
  555.         ." moving by recompiling " old# . ."  to " new# . cr
  556.     then
  557.  
  558.     theOD copyWithCDP: self
  559.     get: ivar> refcnt in theOD  put: refcnt
  560.     recompile: self
  561.  
  562.     old# new# addr: myRef  check_for_moved_stores
  563.     
  564.     old# true reg_moved: self
  565.     true
  566. ;m
  567.  
  568.  
  569. :m MOVEREG:  { old# new# updateRefs? ¥ extraRefs? -- }
  570.  
  571.     debug? recompTest? or if
  572.         ." moveReg: called, to move " old# . ."  to " new# . cr
  573.     then
  574.  
  575.     new# select: self
  576.     old# new# =  ?EXIT            ¥ just in case
  577.  
  578. ¥ now we need to check if we have any extra refs to this dest reg
  579. ¥  on cstk.  If we do, these refs need the old value, so we'll have
  580. ¥  to save the old value to a new reg before we change the dest.
  581. ¥ Note that we mustn't do this during equalization when we presumably
  582. ¥  have everything under control and mustn't try to second-guess.
  583.  
  584.     equalizing?
  585.     NIF
  586.         false -> extraRefs?
  587.         size: cstk 1+ 1
  588.         ?DO    i stk: cstk
  589.             addr: myRef =?: cstk
  590.             IF
  591.                 debug? if
  592.                     ." we have another ref to the dest reg, in cell " i . cr
  593.                     printall: cstk
  594.                 then
  595.         
  596.                 extraRefs?
  597.                 NIF        ¥ first time - get the new reg
  598.                     true -> extraRefs?
  599.                     getFreeReg: self  drop
  600.                     new# compile_reg_move: self
  601.                 THEN
  602.                 addr: myRef  ->: cstk
  603.             THEN
  604.         LOOP
  605.     THEN
  606.  
  607.     old# new# moveReg_by_recompiling?: self  ?EXIT
  608.     new# select: self
  609.     old# compile_reg_move: self
  610.     
  611.     debug? recompTest? or if
  612.         ." moved by compiling a move, from " old# . ."  to " new# . cr
  613.     then
  614.  
  615.     old# -1  addr: myRef  check_for_moved_stores
  616.     updateRefs?
  617.     IF    old# false reg_moved: self
  618.         new# select: self
  619.     THEN
  620. ;m
  621.  
  622. :m indexedOpCDP:
  623.     current: self >r
  624.     select: self
  625.     get: permanent? IF  16  ELSE  get: opCDP  THEN
  626.     r> select: self
  627. ;m
  628.  
  629. :m USE_THIS:  ( CDP_to_use reg# -- )
  630.     current: self >r
  631.     select: self  mark_use: super
  632.     r> select: self
  633. ;m
  634.  
  635. :m PRINT:
  636.     cr
  637.     ." current: "  get: current  .
  638.     print: super
  639. ;m
  640.  
  641. :m PRINTALL:
  642.     cr
  643.     ." current: "  get: current  dup .  cr
  644.     ." last allocated:  " print: last_allocated  cr
  645.  
  646.     limit 0
  647.     DO    i select: self
  648.         get: opType
  649.         IF
  650.             i .  print: super  cr
  651.         THEN
  652.     LOOP
  653.     select: self
  654. ;m
  655.  
  656. :m .ALLOCATED:
  657.     get: current
  658.     limit 0
  659.     DO    i select: self  get: refCnt
  660.         IF  i .  4 spaces ." refCnt "  get: refCnt .  cr
  661.         THEN
  662.     LOOP  cr
  663.     select: self
  664. ;m
  665.  
  666. :m .FREE:
  667.     cr
  668.     get: current
  669.     limit 0
  670.     DO    i select: self  get: refCnt
  671.         NIF  i .  cr
  672.         THEN
  673.     LOOP
  674.     select: self
  675. ;m
  676.  
  677. :m INIT:  { myRefType my_alloc_limit -- }
  678.     limit 0
  679.     DO    i select: self
  680.         myRefType  >refType: myRef  i >reg: myRef
  681.     LOOP
  682.     my_alloc_limit  put: alloc_limit
  683. ;m
  684.  
  685. :m CLASSINIT:
  686.     clearall: self
  687. ;m
  688.  
  689. PPC?
  690. [IF]        ¥ may not really need this to be conditional, but I'm
  691.             ¥  cautious...
  692.  
  693. :m DEEP_CLASSINIT: { ¥ xx -- }    ¥ Need this for setting up when we initialize ofter
  694.                     ¥  target compilation, since the regular CLASSINIT:
  695.                     ¥  doesn't get done.  Need to override, or it will
  696.                     ¥  just call the method in the first superclass OD.
  697.  
  698.     idxBase 4+  addr: xdispl  displ!
  699.     ^base  classinit: class_as> OD    ¥ actually can omit once it's working
  700.                                     ¥  since ivSetup calls classinit: on
  701.                                     ¥  ALL superclasses.
  702.     (^base) -> newObject
  703.     ['] ODs_class ( dup -> xx )  ifa displace  0  0
  704.     ivSetup
  705. ;m
  706.  
  707. [THEN]
  708.  
  709. ;class
  710.  
  711.  
  712. 32    ODs_class    GPRs            PPC? not [IF]  gprRef 10  init: GPRs  [THEN]
  713. 32    ODs_class    FPRs            PPC? not [IF]  fprRef 13  init: FPRs  [THEN]
  714.  8    ODs_class    CRs                PPC? not [IF]  CRref   7  init: CRs   [THEN]
  715.  
  716. 32    ODs_class    STORED_GPRs        PPC? not [IF]  gprRef 10  init: stored_GPRs  [THEN]
  717. 32    ODs_class    STORED_FPRs        PPC? not [IF]  fprRef 10  init: stored_FPRs  [THEN]
  718.  
  719. ¥ Note: when target compiling we can't send messages at compile time, so we
  720. ¥  can't send init:.  So we do it at SETUP_CG in cg7.  The code there should
  721. ¥  agree with the above.
  722.  
  723.  
  724. objPtr    theRegs  class_is ODs_class        ¥ Used to point to the appropriate bank
  725.                                         ¥  of regs in code which can apply to
  726.                                         ¥  more than one
  727.  
  728.  
  729. ¥ Now we need to permanently allocate regs which we can't use for 
  730. ¥ general operands:
  731.  
  732. : ALLOCATE_RESERVED_REGS
  733.     current: GPRs  current: FPRs
  734.  
  735.     0                allocate_reg: GPRs  special: GPRs
  736.     rX_reg            allocate_reg: GPRs    special: GPRs
  737.     rY_reg            allocate_reg: GPRs    special: GPRs
  738.     rZ_reg            allocate_reg: GPRs    special: GPRs
  739.     SP_reg            allocate_reg: GPRs  special: GPRs
  740.     FSP_reg            allocate_reg: GPRs  special: GPRs
  741.     SP_reg sys_SP_reg <>
  742.     IF
  743.         sys_SP_reg    allocate_reg: GPRs  special: GPRs
  744.     THEN
  745.     RTOC_reg        allocate_reg: GPRs  permanent: GPRs
  746.     mainData_reg    allocate_reg: GPRs  permanent: GPRs
  747.     modData_reg        allocate_reg: GPRs  permanent: GPRs
  748.     mainCode_reg    allocate_reg: GPRs  permanent: GPRs
  749.     modCode_reg        allocate_reg: GPRs  permanent: GPRs
  750.     RP_reg            allocate_reg: GPRs  special: GPRs
  751.     obj_base_reg    allocate_reg: GPRs  permanent: GPRs
  752.  
  753.     32 1st_gpr_local
  754.     DO    i select: GPRs  1 put: ivar> refCnt in GPRs  special: GPRs
  755.     LOOP
  756.  
  757. ¥ now the FPRs
  758.     0                allocate_reg: FPRs  special: FPRs
  759.  
  760.     32 1st_fpr_local
  761.     DO    i select: FPRs  1 put: ivar> refCnt in FPRs  special: FPRs
  762.     LOOP
  763.     
  764.     select: FPRs  select: GPRs
  765. ;
  766.  
  767.  
  768. PPC? not [IF]  allocate_reserved_regs  [THEN]
  769.  
  770.  
  771. ¥ We use these objects to keep track of the operands and results of the
  772. ¥ operation we're currently compiling:
  773.  
  774.     reference    OPND1
  775.     reference    OPND2
  776.     reference    OPND3
  777.     reference    OPND4
  778.     
  779.     reference    RES1
  780.     reference    RES2
  781.     reference    RES3
  782.     
  783.     reference    TMPREF
  784.  
  785.     0    value    EXIT_CHAIN
  786.     
  787.  
  788. :f ALLOCATE_GPR    allocate_reg: GPRs    ;f
  789. :f ALLOCATE_FPR    allocate_reg: FPRs    ;f
  790. :f ALLOCATE_CR    allocate_reg: CRs    ;f
  791.  
  792. :f FREE_GPR        free_reg: GPRs    ;f
  793. :f FREE_FPR        free_reg: FPRs    ;f
  794. :f FREE_CR        free_reg: CRs    ;f
  795.  
  796. :f DEL_GPR        ?delete_reg: GPRs    ;f
  797. :f DEL_FPR        ?delete_reg: FPRs    ;f
  798. :f DEL_CR        ?delete_reg: CRs    ;f
  799.  
  800. :f ?CLEAR_GPR    get: ivar> refCnt in GPRs
  801.                 NIF  clear: ivar> opType in GPRs  1 ++> #gprs_cleared  THEN
  802. ;f
  803.  
  804. :f ?CLEAR_FPR    get: ivar> refCnt in FPRs
  805.                 NIF  clear: ivar> opType in FPRs  THEN
  806. ;f
  807.  
  808. :f ?CLEAR_CR    get: ivar> refCnt in CRs
  809.                 NIF  clear: ivar> opType in CRs  THEN
  810. ;f
  811.  
  812. :f USE_GPR        use_this: GPRs  ;f
  813. :f USE_FPR        use_this: FPRs  ;f
  814. :f USE_CR        use_this: CRs  ;f
  815.  
  816. :f SET_CR0        0 select: CRs
  817.                 put: ivar> opCDP in CRs
  818.                 put: ivar> opType in CRs  ;f
  819.  
  820. :f GPR_CDP        indexedOpCDP: GPRs  ;f
  821. :f FPR_CDP        indexedOpCDP: FPRs  ;f
  822. :f CR_CDP        indexedOpCDP: CRs  ;f
  823.  
  824.  
  825.  
  826. (*    UPDATE_REFCNTS checks cstk and ensures that the refcnt fields in all regs
  827.     are correct.  Basic block boundaries or updating refs may get things out
  828.     of kilter, so this ensures everything's back to what it should be.
  829. *)
  830.  
  831. : UPDATE_REFCNTS
  832.     clear_refCnts: GPRs
  833.     clear_refCnts: FPRs
  834.     clear_refCnts: CRs
  835.  
  836. ¥ don't worry about refCnts in stored_GPRs
  837.  
  838.     size: cstk 1+ 1
  839.     ?DO    i stk: cstk  allocate: cstk
  840.     LOOP
  841.     
  842.     size: fcstk 1+ 1
  843.     ?DO    i stk: fcstk  allocate: fcstk
  844.     LOOP
  845.  
  846.     allocate_reserved_regs
  847. ;
  848.  
  849.  
  850. : MAKE_ALTERED_REGS_UNKNOWN
  851.     [ debug? ] [if]
  852.         ." make_altered_regs_unknown called" cr
  853.     [then]
  854.     make_altered_regs_unknown: GPRs
  855.     make_altered_regs_unknown: FPRs
  856.     make_altered_regs_unknown: CRs
  857.     make_altered_regs_unknown: stored_GPRs
  858. ;
  859.  
  860.  
  861. objPtr    match_regs        class_is  ODs_class
  862. objPtr  stored_regs        class_is  ODs_class
  863.  
  864. : match_stores?  { ^regs ^stored_regs ^OD store-code canBeSpecial? 
  865.                     ¥ sv_opType -- ^OD' true | -- false }
  866.  
  867.     ^regs -> match_regs  ^stored_regs -> stored_regs
  868.  
  869.     debug? if
  870.         ." match? didn't match fetch on regs" cr
  871.         ." - now attempting to match with stored regs:" cr
  872.         print: [ ^OD ]
  873.         cr ." stored regs: " cr
  874.         printall: stored_regs cr
  875.     then
  876.  
  877.     ^OD  get: ivar> opType in class_as> OD  -> sv_opType
  878.     store-code  ^OD put: ivar> opType in class_as> OD
  879.     
  880.     ^OD  canBeSpecial?  match?: stored_regs
  881.     
  882.     sv_opType  ^OD put: ivar> opType in class_as> OD        ¥ restore it
  883.  
  884.     debug? if
  885.         dup if ." matched on stored regs" else ." didn't match stored regs" then cr cr
  886.     then
  887.  
  888.     NIF    false    EXIT  THEN
  889.  
  890. ¥ we've matched on a stored reg.  We use it, but change its type 
  891. ¥  in GPRs/FPRs to otUnknown so we can't change it again.  Any attempt
  892. ¥  to recompile it, say, would clobber the store (the voice of
  893. ¥  experience).
  894.  
  895.     current: stored_regs  select: match_regs
  896.  
  897.     addr: stored_regs  copyOD: match_regs
  898.     otUnknown  put: ivar> opType in match_regs
  899.     debug? if
  900.         ." changed type in match_regs to otUnknown:"
  901.         print: match_regs
  902.     then
  903.     CDP  put: ivar> lastRefCDP in match_regs
  904.     big# put: ivar> validTillCDP in match_regs
  905.     addr: match_regs  true
  906. ;
  907.  
  908.  
  909. : MATCH?  { ^OD canBeSpecial? ¥ opType -- ^OD' true | -- false }
  910.  
  911.     allow_match?  NIF  false  EXIT  THEN
  912.  
  913.     ^OD get: ivar> opType in OD  -> opType
  914.     
  915.     opType  otFPstart otFPend  within? nip
  916.     IF                                ¥ it's an FP op - just check FPRs
  917.         ^OD canBeSpecial?  match?: FPRs
  918.         IF  addr: FPRs    true  ELSE  false  THEN  EXIT
  919.     THEN
  920.  
  921.     ^OD canBeSpecial?  match?: GPRs        IF  addr: GPRs    true  EXIT  THEN
  922.     ^OD canBeSpecial?  match?: CRs        IF  addr: CRs    true  EXIT  THEN
  923.  
  924. ¥ now if the op is a fetch, we need to check for a match on the stores of
  925. ¥  that kind of register.
  926.  
  927.     opType otFetch =
  928.     IF    GPRs stored_GPRs ^OD otStore canBeSpecial? match_stores?  EXIT  THEN
  929.     opType otFPfetch =
  930.     IF  FPRs stored_FPRs ^OD otFPstore canBeSpecial? match_stores?  EXIT  THEN
  931.  
  932.     false
  933. ;
  934.  
  935.  
  936.  
  937. objPtr    rcRef    class_is reference
  938.  
  939. :f REG_CHANGED  { ^ref -- }
  940.     ^ref reg_changed: GPRs
  941.     ^ref reg_changed: FPRs
  942.     ^ref reg_changed: CRs
  943.     
  944. ¥ Now if this is a GPR, we also clobber the corresponding element in
  945. ¥ stored_GPRs, since any value that was stored isn't in this GPR any more.
  946.  
  947.     ^ref -> rcRef
  948.     refType: rcRef  GPRref =
  949.     IF    reg: rcRef  select: stored_GPRs
  950.         clear: ivar> opType in stored_GPRs
  951.     THEN
  952. ;f
  953.  
  954.  
  955. : UPDATE_EQ_RANGES
  956.     reset: eq_ranges
  957.     BEGIN
  958.         len: eq_ranges  0EXIT
  959.         nxtL: eq_ranges  startCDP u>
  960.     UNTIL
  961.     -4 skip: eq_ranges
  962.     BEGIN
  963.         1stL: eq_ranges
  964.         deltaCDP +  >nxtL: eq_ranges
  965.         len: eq_ranges
  966.         dup 0< if . ."  auugggh!" QUIT then
  967.     NUNTIL
  968. ;
  969.  
  970.  
  971. :f UPDATE_CDPs        ¥ ( startCDP deltaCDP -- )
  972.  
  973.     -> deltaCDP  -> startCDP
  974.     update_opCDPs: GPRs
  975.     update_opCDPs: FPRs
  976.     update_opCDPs: CRs
  977.     
  978.     update_opCDPs: stored_GPRs
  979.     
  980.     basic_block_start  startCDP u>
  981.     IF  deltaCDP ++> basic_block_start  THEN
  982.  
  983.     loop_start  startCDP u>
  984.     IF  deltaCDP ++> loop_start  THEN
  985.  
  986.     update: control_stk
  987.     update_eq_ranges
  988.     fix_containing_loop
  989. ;f
  990.  
  991.  
  992. objPtr  MS_check_regs    class_is ODs_class
  993.  
  994. :f check_for_moved_stores  { old# new# ^ref -- }
  995.  
  996.     ^ref  refType: class_as> reference
  997.  
  998.     SELECT[    GPRref    ]=>        stored_GPRs -> MS_check_regs
  999.           [    FPRref    ]=>        stored_FPRs -> MS_check_regs
  1000.               DEFAULT=>  drop  EXIT
  1001.     ]SELECT
  1002.  
  1003.     old# select: MS_check_regs
  1004.     get: ivar> opType in MS_check_regs  otStore =
  1005.     IF
  1006.         new# 0>=
  1007.         IF
  1008.             debug? if
  1009.                 cr
  1010. ." moving a store since source reg has moved from " old# . ." to " new# . cr
  1011.             then
  1012.  
  1013.             addr: MS_check_regs
  1014.             new# select: MS_check_regs
  1015.             copyWithCDP: MS_check_regs
  1016.             recompile: MS_check_regs
  1017.             old# select: MS_check_regs
  1018.         THEN
  1019.         clear: ivar> opType in MS_check_regs
  1020.     THEN
  1021. ;f
  1022.  
  1023.  
  1024. false    value    USING_CR0
  1025.  
  1026.  
  1027. (* MOVE_CR_BIT moves a bit in the CR from one position to another.
  1028.    Note that we can't do this by recompiling the op, since the op
  1029.    was a compare or an arith instruction that necessarily put the
  1030.    bit where it ended up (except for the one case where it was a
  1031.    test for the SAME condition which happened to be sent to a different
  1032.    CR field).
  1033.    The move can be done in one instruction - either a cror or crnor
  1034.    depending on whether the 1_is_true? bit is the same or different.
  1035. *)
  1036.  
  1037. : MOVE_CR_BIT  { srcRef dstRef ¥ whichSrcBit whichDstBit -- }
  1038.     debug? if
  1039.         ." move_cr_bit called with: "  print: [ srcRef ]  print: [ dstRef ] cr
  1040.     then
  1041.  
  1042.     false -> check_OP_stores?    ¥ classes mightn't match (might be cstk)
  1043.                                 ¥  but doesn't matter here
  1044.     srcRef -> aRef
  1045.     dstRef -> aRef2
  1046.     true -> check_OP_stores?
  1047.  
  1048.     clear: instrn
  1049.     19 >primOp: instrn
  1050.     1_is_true?: aRef  1_is_true?: aRef2  =
  1051.     IF        449                    ¥ cror
  1052.     ELSE    33                    ¥ crnor
  1053.     THEN  >secOp: instrn
  1054.     reg: aRef  4*  bit#: aRef  or  -> whichSrcBit
  1055.     reg: aRef2 4*  bit#: aRef2 or  -> whichDstBit
  1056.     whichSrcBit dup >rA: instrn  >rB: instrn
  1057.     whichDstBit  >rD: instrn
  1058.     compile: instrn
  1059. ;
  1060.  
  1061.  
  1062. ¥            ===============================================
  1063.  
  1064. ¥ More utility words
  1065.  
  1066.  
  1067. : STK    ¥ Selects the nth cstk cell (1 is top)
  1068.     stk: cstk  ;
  1069.  
  1070. : FSTK
  1071.     stk: fcstk  ;
  1072.  
  1073. : POP  { ^ref -- }
  1074.     size: cstk
  1075.     IF    1 stk  cstk ^ref ->: class_as> reference
  1076.         -1 +size: cstk
  1077.     ELSE        ¥ no operands in regs - we just have to adjust stk_offset
  1078.         1cell  ++> stk_offset
  1079.         noRef  ^ref >refType: class_as> reference
  1080.     THEN
  1081. ;
  1082.  
  1083. : FPOP  { ^ref -- }
  1084.     size: fcstk
  1085.     IF    1 fstk  fcstk ^ref ->: class_as> reference
  1086.         -1 +size: fcstk
  1087.     ELSE        ¥ no operands in regs - we just have to adjust stk_offset
  1088.         fpcell  ++> fstk_offset
  1089.         noRef  ^ref >refType: class_as> reference
  1090.     THEN
  1091. ;
  1092.  
  1093. : PUSH    ¥ ( ^ref -- )
  1094.     push: cstk  ;
  1095.  
  1096. : FPUSH    ¥ ( ^ref -- )
  1097.     push: fcstk  ;
  1098.  
  1099.  
  1100. : INIT_CSTK
  1101.     0 >size: cstk  ;
  1102.  
  1103. : INIT_FCSTK
  1104.     0 >size: fcstk  ;
  1105.  
  1106.  
  1107. : INIT_GPRs
  1108.     debug? if
  1109.         ." init_gprs called - clearing everything" cr
  1110.     then
  1111.  
  1112.     clearAll: GPRs
  1113.     clearAll: CRs
  1114.     clearAll: stored_GPRs
  1115.     allocate_reserved_regs
  1116. ;
  1117.  
  1118. : INIT_FPRs
  1119.     debug? if
  1120.         ." init_fprs called - clearing everything" cr
  1121.     then
  1122.  
  1123.     clearAll: FPRs
  1124.     clearAll: stored_FPRs
  1125.     allocate_reserved_regs
  1126. ;
  1127.  
  1128.  
  1129. : INIT_VOLATILE_GPRs
  1130.  
  1131.     debug? if
  1132.         ." init_volatile_gprs called" cr
  1133.     then
  1134.  
  1135.     13 clearAllWithBoundary: GPRs
  1136.     clearAll: CRs
  1137.     clearAll: stored_GPRs
  1138.     allocate_reserved_regs
  1139. ;
  1140.  
  1141. : INIT_VOLATILE_FPRs
  1142.  
  1143.     debug? if
  1144.         ." init_volatile_gprs called" cr
  1145.     then
  1146.  
  1147.     14 clearAllWithBoundary: FPRs
  1148.     clearAll: stored_FPRs
  1149.     allocate_reserved_regs
  1150. ;
  1151.  
  1152.  
  1153. : set_backstop_CDP
  1154.     CDP -> backstop_CDP  ( init_volatile_regs )
  1155. ;
  1156.  
  1157.  
  1158. : (SETUP_CSTK)  { #gprs init? -- }
  1159.     init? IF  init_gprs  ELSE  init_volatile_gprs  THEN
  1160.     init_cstk
  1161.     #gprs 0
  1162.     ?DO    i 3+ dup allocate_reg: GPRs  >GPR: res1
  1163.         otUnknown  put: ivar> opType in GPRs
  1164.         noType       put: ivar> instrnType in GPRs
  1165.         res1 push
  1166.     LOOP
  1167. ;
  1168.  
  1169. : (SETUP_FCSTK)  { #fprs init? -- }
  1170.     init? IF  init_fprs  ELSE  init_volatile_fprs  THEN
  1171.     init_fcstk
  1172.     #fprs 0
  1173.     ?DO    i 1+ dup allocate_reg: FPRs  >FPR: res1
  1174.         otUnknown  put: ivar> opType in FPRs
  1175.         noType       put: ivar> instrnType in FPRs
  1176.         res1 fpush
  1177.     LOOP
  1178. ;
  1179.  
  1180.  
  1181. : SETUP_CSTK  ( #gprs -- )
  1182.     true  (setup_cstk)  ;
  1183.  
  1184. : RESET_CSTK  ( #gprs -- )
  1185.     false  (setup_cstk)  ;
  1186.  
  1187. : SETUP_FCSTK  ( #fprs -- )
  1188.     true  (setup_fcstk)  ;
  1189.  
  1190. : RESET_FCSTK  ( #fprs -- )
  1191.     false  (setup_fcstk)  ;
  1192.  
  1193.  
  1194. :f UPDATE_REFS  { ^oldRef ^newRef fromCDP -- }        ¥ this isn't a big bottleneck
  1195.     ^oldRef ^newRef fromCDP  update_all_refs: GPRs
  1196.     ^oldRef ^newRef fromCDP  update_all_refs: FPRs
  1197.     ^oldRef ^newRef fromCDP  update_all_refs: CRs
  1198.     ^oldRef ^newRef fromCDP  update_all_refs: stored_GPRs
  1199.  
  1200.     size: cstk  0EXIT
  1201.     current: cstk
  1202.     size: cstk FOR
  1203.         i select: cstk
  1204.         ^oldRef =?: cstk  IF  ^newRef ->: cstk  THEN
  1205.     NEXT
  1206.     update_refCnts
  1207.     select: cstk
  1208. ;f
  1209.  
  1210.  
  1211.  
  1212. : OPERANDS { n ¥ #toPull siz -- }
  1213.     (* Ensures we have the top n stk cells in regs for a subsequent
  1214.        operation.  Pops n operands off cstk, and moves them to opnd1, opnd2
  1215.        etc., with opnd1 being the LOWEST stack cell.
  1216.        We could also free the regs, which would be safe if
  1217.        we allocate the the result reg(s) first.  But I'd have to check
  1218.        if the reference is actually a reg, and this has to be done anyway
  1219.        when I compile the op. So it might be easier to free the reg
  1220.        there, not here.
  1221.     *)
  1222.  
  1223.     size: cstk  -> siz
  1224.     n  siz  >        ¥ do we need to pull cells out of memory?
  1225.     IF    n  size: cstk -  -> #toPull
  1226.         #toPull
  1227.         FOR        getFreeReg: GPRs  >gpr: res1
  1228.                 SP_reg stk_offset 0 compPull: GPRs
  1229.                 1cell  ++> stk_offset
  1230.                 movedown: cstk  res1 ->: cstk
  1231.         NEXT
  1232.     THEN
  1233.     n
  1234.     SELECT[    1    ]=>    1 stk  cstk ->: opnd1
  1235.                     -1 +size: cstk
  1236.     
  1237.           [ 2    ]=>    2 stk  cstk ->: opnd1
  1238.                       1 stk  cstk ->: opnd2
  1239.                       -2 +size: cstk
  1240.  
  1241.           [ 3    ]=>    3 stk  cstk ->: opnd1
  1242.                       2 stk  cstk ->: opnd2
  1243.                       1 stk  cstk ->: opnd3
  1244.                       -3 +size: cstk
  1245.  
  1246.           [ 4    ]=>    4 stk  cstk ->: opnd1
  1247.                       3 stk  cstk ->: opnd2
  1248.                       2 stk  cstk ->: opnd3
  1249.                       1 stk  cstk ->: opnd4
  1250.                       -4 +size: cstk
  1251.  
  1252.         DEFAULT=>    ." illegal parameter to OPERANDS : " .  1 die
  1253.     ]SELECT
  1254. ;
  1255.  
  1256. : FOPERANDS { n ¥ #toPull siz -- }
  1257.  
  1258.     size: fcstk  -> siz
  1259.     n  siz  >        ¥ do we need to pull cells out of memory?
  1260.     IF    n  size: fcstk -  -> #toPull
  1261.         #toPull
  1262.         FOR        getFreeReg: FPRs  >fpr: res1
  1263.                 FSP_reg fstk_offset 0 compPull: FPRs
  1264.                 FPcell  ++> fstk_offset
  1265.                 movedown: fcstk  res1 ->: fcstk
  1266.         NEXT
  1267.     THEN
  1268.     n
  1269.     SELECT[    1    ]=>    1 fstk  fcstk ->: opnd1
  1270.                     -1 +size: fcstk
  1271.     
  1272.           [ 2    ]=>    2 fstk  fcstk ->: opnd1
  1273.                       1 fstk  fcstk ->: opnd2
  1274.                       -2 +size: fcstk
  1275.  
  1276.           [ 3    ]=>    3 fstk  fcstk ->: opnd1
  1277.                       2 fstk  fcstk ->: opnd2
  1278.                       1 fstk  fcstk ->: opnd3
  1279.                       -3 +size: fcstk
  1280.  
  1281.           [ 4    ]=>    4 fstk  fcstk ->: opnd1
  1282.                       3 fstk  fcstk ->: opnd2
  1283.                       2 fstk  fcstk ->: opnd3
  1284.                       1 fstk  fcstk ->: opnd4
  1285.                       -4 +size: fcstk
  1286.  
  1287.         DEFAULT=>    ." illegal parameter to OPERANDS : " .  1 die
  1288.     ]SELECT
  1289. ;
  1290.  
  1291. : RESULTS    ¥ ( n -- )  Reserves n GPRs for results
  1292.  
  1293.     SELECT[    1    ]=>        getFreeReg: GPRs  >gpr: res1
  1294.     
  1295.           [ 2    ]=>        getFreeReg: GPRs  >gpr: res1
  1296.                           getFreeReg: GPRs  >gpr: res2
  1297.  
  1298.         DEFAULT=>    ." illegal parameter to RESULTS : " .  1 die
  1299.     ]SELECT
  1300. ;
  1301.  
  1302. : FRESULTS    ¥ ( n -- )  Reserves n FPRs for results
  1303.  
  1304.     SELECT[    1    ]=>        getFreeReg: FPRs  >fpr: res1
  1305.     
  1306.           [ 2    ]=>        getFreeReg: FPRs  >fpr: res1
  1307.                           getFreeReg: FPRs  >fpr: res2
  1308.  
  1309.         DEFAULT=>    ." illegal parameter to RESULTS : " .  1 die
  1310.     ]SELECT
  1311. ;
  1312.  
  1313. : SWAP_CSTK
  1314.     2 operands
  1315.     opnd2 push  opnd1 push  ;
  1316.  
  1317. : ROT_CSTK
  1318.     3 operands
  1319.     opnd2 push  opnd3 push  opnd1 push  ;
  1320.  
  1321.  
  1322. (*    CR_RESULT reserves a CR field.  If it's for a comparison result,
  1323.     the actual condition must be in subOperation.  The result is
  1324.     left in res1, and the allocated CR reg is left selected.
  1325.     If it's just to get a free CR reg for a CR logical operation, 
  1326.     don't bother setting subOperation, and ignore res1.
  1327.     If we want a particular CR (which may be CR0 for an integer op or CR1
  1328.     for an FP op, we pass true for wantOne? as well as the reg# we want
  1329.     and the CDP where the op is to be compiled.  If we don't want a
  1330.     particular one, we pass false and the other two parameters are ignored.
  1331. *)
  1332.  
  1333. : CR_RESULT  { wantOne? CR#_wanted CDP_where_used ¥ gotit? -- }
  1334.     false  -> gotit?
  1335.     wantOne?
  1336.     IF    CR#_wanted select: CRs
  1337.         get: ivar> refCnt in CRs
  1338.         NIF    get: ivar> opCDP in CRs  CDP_where_used  u<=  -> gotit?
  1339.         THEN
  1340.         
  1341.         gotit?
  1342.         IF    allocate: CRs  CR#_wanted  THEN
  1343.     THEN
  1344.     
  1345.     gotit?
  1346.     NIF
  1347.         0 select: CRs  allocate: CRs    ¥ temporarily, to ensure they won't be free
  1348.         1 select: CRs  allocate: CRs
  1349.         getFreeReg: CRs
  1350.         0 select: CRs  free: CRs
  1351.         1 select: CRs  free: CRs
  1352.     THEN
  1353.     
  1354. ( CR# we got )
  1355.     dup >CR: res1  select: CRs
  1356.     subOperation >condition: res1
  1357.     res1 ->: ivar> myRef in CRs
  1358. ;
  1359.  
  1360.  
  1361.  
  1362. 0    value    svSelector
  1363. 0    value    svOpcode
  1364.  
  1365. objPtr    matchedOD  class_is OD
  1366.  
  1367. : MATCH&ALLOCATE?  { canBeSpecial? -- b }
  1368.     theOD canBeSpecial?  match?  NIF  false  EXIT  THEN
  1369.     
  1370.     false -> check_OP_stores?
  1371.     -> matchedOD
  1372.     true -> check_OP_stores?
  1373.  
  1374.     debug? if
  1375.         ." match&allocate? matched on reg: "  print: matchedOD  cr
  1376.     then
  1377.     allocate: matchedOD  addr: ivar> myRef in matchedOD  ->: res1
  1378.  
  1379. ¥ if it's a CR result, although we've matched on the CR field, the
  1380. ¥ condition might be different.  So we make sure we set the right
  1381. ¥ condition in res1 and the matching CR reg.  The condition should
  1382. ¥ be in subOperation.
  1383.  
  1384.     refType: res1  crRef =
  1385.     IF    subOperation >condition: res1
  1386.         res1 ->: ivar> myRef in CRs
  1387.     THEN
  1388.     true
  1389. ;
  1390.  
  1391.  
  1392. ¥ LIT>GPR compiles the passed in literal value in a gpr, and leaves
  1393. ¥  res1 set to that gpr.  Uses theOD.  
  1394. ¥ Note: This is only called from equalization, where we mustn't ever ever 
  1395. ¥  generate duplicate references (since we're getting rid of them!),
  1396. ¥  so we don't look for a match.
  1397.  
  1398. : LIT>GPR  { n canBeSpecial? -- }
  1399.     n setLit: theOD
  1400.  
  1401.     debug? if
  1402.         ." lit>gpr - theOD:" print: theOD
  1403.     then
  1404.  
  1405. ¥    canBeSpecial?  match&allocate?  ?EXIT - aauugghhh!!
  1406.     getFreeReg: GPRs  >gpr: res1
  1407.     theOD ->: GPRs  compile: GPRs
  1408. ;
  1409.  
  1410.  
  1411. : LIT>SELECTED_GPR  { n -- }
  1412.     n setLit: GPRs
  1413.     compile: GPRs
  1414. ;
  1415.  
  1416. : LIT>THIS_GPR  { n gpr# -- }
  1417.     gpr# select: GPRs
  1418.     n setLit: GPRs  compile: GPRs
  1419. ;
  1420.  
  1421.  
  1422. 0    value    #CRs_pushed
  1423. 0    value    #FPRs_pushed
  1424.  
  1425.  
  1426.  
  1427. (*    CR>THIS_GPR compiles the sequence to convert a CR bit reference to
  1428.     a true or false in the GPR whose number is passed in.
  1429.     
  1430.     This stuff looks incredibly complicated, but that's because we try
  1431.     to generate the optimized sequences given in the Compiler Writers'
  1432.     Guide, whenever we can, and there are a lot of special cases.
  1433.     
  1434.     One way to do the job would be to put a -1 into the reg, then
  1435.     conditionally branch over a clear of the reg.  But we should always try 
  1436.     to eliminate branches.  The most general way is to move the CR to a reg, 
  1437.     then rotate-left-and-mask to get the desired bit into the low bit position 
  1438.     of the reg.  Then unlike C, we need to add a negate or a subtact 1, so that
  1439.     we get a proper true flag.  We handle this general case in do_cr_op below.
  1440.     
  1441.     But in most cases we can do better.  The Guide says that CR ops can
  1442.     cause a stall since they operate on the whole CR, and so clobber any
  1443.     parallelism involving different CR fields.  So if we can, we avoid
  1444.     using a CR op.  Now if the CR result is a comparison (which it usually is), 
  1445.     then we can change the op to a subfc or something similar, then do 2 or 3 
  1446.     instructions of bit twiddling to get a flag without any CR ops or branches.
  1447.     The code sequences are very obscure, involving some unobvious uses of the 
  1448.     carry flag.
  1449.     
  1450.     All this is further complicated by the fact that we can't really compile
  1451.     arbitrary code here since
  1452.     1. Routines like compRegReg aren't re-entrant, and
  1453.        assume theOD stays valid.
  1454.     2. We might be called from within equalization which means we should
  1455.        leave other regs alone.
  1456.     3. We can't use r12 (rY) since we might be in the middle of setting
  1457.        up a method call.  We can use r10 and r11 (rX and rZ).
  1458.     4. If we have to do the subtract 1, we can't be in r0 (addi doesn't work
  1459.         (on r0).
  1460.     
  1461.     So we basically use rX, rZ and r0 where we can, target the destination
  1462.     gpr with the final instruction, hand-wind things and leave everything 
  1463.     else alone.
  1464.  
  1465.     We also free the CR here since that usually simplifies things for the 
  1466.     caller, and we're definitely finished with the CR once we've moved its 
  1467.     value to a GPR.
  1468. *)
  1469.  
  1470.  
  1471. : make_flag  { reg1 reg2 gpr# 1_is_true? otCode -- }
  1472.  
  1473.     1_is_true?
  1474.     IF  gpr#  ELSE  rZ_reg  THEN  select: GPRs
  1475.  
  1476.     reg2 >Agpr: GPRs  reg1 >Bgpr: GPRs
  1477.     otCode put: ivar> opType in GPRs
  1478.     compile: GPRs
  1479.     
  1480.     1_is_true?
  1481.     NIF
  1482.         gpr# select: GPRs
  1483.         rZ_reg >Agpr: GPRs  clear: ivar> B_opnd in GPRs
  1484.         otNOT put: ivar> opType in GPRs
  1485.         compile: GPRs
  1486.     THEN
  1487.     set: ivar> dontHoist? in GPRs    ¥ it depends on hand-wound preceding
  1488.                                     ¥  code, so mustn't move
  1489. ;
  1490.  
  1491.  
  1492. : make_flag_for_zcomp  { reg gpr# litval otCode subcode -- }
  1493.     gpr# select: GPRs
  1494.     otCode put: ivar> opType in GPRs 
  1495.     subcode put: ivar> subtype in GPRs        ¥ right arithmetic shift
  1496.     reg >Agpr: GPRs
  1497.     litval >Blit: GPRs
  1498.     compile: GPRs
  1499.     set: ivar> dontHoist? in GPRs
  1500. ;
  1501.  
  1502.  
  1503. : do_signed_comp_with_zero  { reg gpr# rev? 1_is_true? -- }
  1504.  
  1505. ¥    reg >Agpr: GPRs
  1506.  
  1507.     rev?
  1508.     IF    1_is_true?
  1509.         IF                            ¥ 0>
  1510.             otSubfc put: ivar> opType in GPRs
  1511.             0 >Blit: GPRs
  1512.             compile: GPRs
  1513.  
  1514. ¥            0 gpr# 31 otShift 3  make_flag_for_zcomp
  1515.  
  1516.             $ 540A0FFE
  1517.             reg 21 << or  code,        ¥ rlwinm  rZ, reg, 1, 31, 31
  1518.  
  1519.             rZ_reg dup gpr# true otAddme  make_flag
  1520.  
  1521.         ELSE                        ¥ 0<=
  1522.         
  1523.             otAddc  put: ivar> opType in GPRs
  1524.             -1 >Blit: GPRs
  1525.             compile: GPRs
  1526.             
  1527. ¥            0 gpr# 31 otShift 3  make_flag_for_zcomp
  1528. ¥
  1529. ¥            otAddic put: ivar> opType in GPRs
  1530. ¥            -1 >Blit: GPRs
  1531. ¥            compile: GPRs
  1532. ¥
  1533.             $ 540A0FFE
  1534.             reg 21 << or  code,        ¥ rlwinm  rZ, reg, 1, 31, 31
  1535.  
  1536.             rZ_reg dup gpr# true otSubfze  make_flag
  1537.  
  1538.         THEN
  1539.     ELSE
  1540.         1_is_true?
  1541.         IF                            ¥ 0<
  1542.             reg gpr# 31 otShift 3  make_flag_for_zcomp
  1543.         ELSE                        ¥ 0>=
  1544.             $ 540A0FFE
  1545.             reg 21 << or  code,        ¥ rlwinm  rZ, reg, 1, 31, 31
  1546.             rZ_reg gpr# -1 otAdd 0  make_flag_for_zcomp
  1547.         THEN
  1548.     THEN
  1549. ;
  1550.  
  1551.  
  1552. : do_signed_lit_op  { reg gpr# litval rev? 1_is_true? -- }
  1553.  
  1554.     0 select: GPRs
  1555.     reg >Agpr: GPRs
  1556. ¥    addr: CRs copyWithCDP: GPRs
  1557. ¥    delete: CRs                        ¥ we'll instead be doing an op into r0
  1558.     clear: ivar> subtype in GPRs    ¥ we always want this
  1559.  
  1560.     litval
  1561.     NIF  reg gpr# rev? 1_is_true?  do_signed_comp_with_zero  EXIT  THEN
  1562.  
  1563.     1_is_true?
  1564.     NIF
  1565.         rev? IF  1 ++> litval  ELSE  1 --> litval  THEN
  1566.         not> rev?
  1567.     THEN
  1568.  
  1569.     rev?
  1570.     NIF        rX_reg  rZ_reg  litval negate    otAddc
  1571.     ELSE    rZ_reg  rX_reg  litval            otSubfc
  1572.     THEN
  1573.     put: ivar> opType in GPRs
  1574.     >Blit: GPRs
  1575.     compile: GPRs
  1576.  
  1577.   ( rZ/rX ) 21 <<
  1578.     $ 39400000  or
  1579.     litval 31 >> or  code,        ¥ li        rZ/rX, 1/0
  1580.   ( rX/rZ )  16 <<
  1581.     $ 54000FFE  or
  1582.     reg 21 << or  code,            ¥ rlwinm    rX/rZ, reg, 1, 31, 31
  1583.  
  1584.     rX_reg  rZ_reg  gpr#  true  otSubfe  make_flag
  1585. ;
  1586.  
  1587.  
  1588. : do_signed_op  { reg1 reg2 gpr# litval 1_is_true? -- }
  1589.  
  1590.     reg1 0< IF  reg2 gpr# litval false 1_is_true?  do_signed_lit_op  EXIT  THEN
  1591.     reg2 0< IF  reg1 gpr# litval true  1_is_true?  do_signed_lit_op  EXIT  THEN
  1592.  
  1593.     1_is_true?
  1594.     IF    $ 540A0FFE
  1595.         reg1 21 << or  code,    ¥    rlwinm    rZ, reg1, 1, 31, 31
  1596.         $ 540B0FFE
  1597.         reg2 21 << or  code,    ¥    rlwinm    rX, reg2, 1, 31, 31
  1598.         otSubfc
  1599.     ELSE
  1600.         $ 6C0A8000 
  1601.         reg1 21 << or  code,    ¥    xoris    rZ, reg1, $ 8000
  1602.         otSub
  1603.     THEN
  1604.  
  1605.     0 select: GPRs
  1606. ¥    addr: CRs copyWithCDP: GPRs
  1607. ¥    delete: CRs            ¥ we'll instead be doing some kind of subtract into r0
  1608.  ( code ) put: ivar> opType in GPRs  clear: ivar> subtype in GPRs
  1609.      reg2 >Agpr: GPRs  reg1 >Bgpr: GPRs
  1610.     compile: GPRs
  1611.     1_is_true?
  1612.     IF
  1613.         rX_reg  rZ_reg
  1614.     ELSE
  1615.         $ 7C005014  code,        ¥    addc    r0, r0, rZ
  1616.         0  0
  1617.     THEN
  1618.     gpr#  true  otSubfe  make_flag
  1619. ;
  1620.  
  1621.  
  1622. : do_unsigned_op  { reg1 reg2 gpr# litval 1_is_true? -- }
  1623.  
  1624.     rZ_reg select: GPRs
  1625. ¥    addr: CRs copyWithCDP: GPRs
  1626. ¥    delete: CRs                ¥ we'll instead be doing a subfc into rZ
  1627.  
  1628.     reg2 0<
  1629.     IF
  1630.         litval >Blit: GPRs
  1631.         reg1  otSubfc
  1632.     ELSE
  1633.         reg1 0<
  1634.         IF    litval negate >Blit: GPRs
  1635.             reg2  otAddc
  1636.         ELSE
  1637.             reg1 >Bgpr: GPRs
  1638.             reg2  otSubfc
  1639.         THEN
  1640.     THEN
  1641.     put: ivar> opType in GPRs  >Agpr: GPRs
  1642.     clear: ivar> subtype in GPRs
  1643.     compile: GPRs                ¥ subfc  rZ, reg1, reg2 or whatever
  1644.  
  1645.     rZ_reg dup gpr# 1_is_true? otSubfe  make_flag
  1646. ;
  1647.  
  1648.  
  1649. : do_zero_test  { reg1 gpr# 1_is_true? -- }
  1650.     reg1 >Agpr: GPRs
  1651.     1_is_true?
  1652.     IF
  1653.         -1 >Blit: GPRs
  1654.         otAddc put: ivar> opType in GPRs
  1655.     ELSE
  1656.         0 >Blit: GPRs
  1657.         otSubfc put: ivar> opType in GPRs
  1658.     THEN
  1659.     compile: GPRs
  1660.  
  1661.     rZ_reg dup gpr# true otSubfe  make_flag
  1662.                             ¥ flag will be already the right way around
  1663.                             ¥  so we pass true, not 1_in_true? - and we
  1664.                             ¥  won't need the adjustment instruction.
  1665. ;
  1666.  
  1667.  
  1668. : do_equality  { reg1 reg2 gpr# litval 1_is_true? -- }
  1669.     rZ_reg select: GPRs
  1670. ¥    addr: CRs copyWithCDP: GPRs        ¥ we'll be replacing the compare with an xor
  1671.                                     ¥  into rZ, and not use the CR field at all
  1672.  
  1673.     otXOR put: ivar> opType in GPRs  clear: ivar> subtype in GPRs
  1674.     reg1 >Agpr: GPRs
  1675.     reg2 0<
  1676.     IF            ¥ it's literal - and if zero, we can do even better, by
  1677.                 ¥  deleting the CR op, omitting the xor entirely, and
  1678.                 ¥  skipping straight to our final zero test.
  1679.         litval
  1680.         NIF
  1681. ¥            delete: CRs
  1682.             reg1 gpr# 1_is_true?  do_zero_test  EXIT
  1683.         THEN
  1684.         litval >Blit: GPRs
  1685.     ELSE
  1686.         reg2 >Bgpr: GPRs
  1687.     THEN
  1688. ¥    recompile: GPRs                    ¥ xor  rZ, reg1, reg2 / xori rZ, reg1, litval
  1689.     compile: GPRs
  1690.  
  1691.     rZ_reg gpr# 1_is_true?  do_zero_test
  1692.  
  1693. ¥    update_refcnts
  1694.     debug? if
  1695.         ." cr>this_gpr used do_equality, leaving result in:" print: GPRs  cr dasm .al
  1696.     then
  1697. ;
  1698.  
  1699.  
  1700. : do_cr_op  { gpr# field# bit# 1_is_true? -- }
  1701.  
  1702.     rX_reg  select: GPRs
  1703.  
  1704.     $ 7C000026  rX_reg 21 << or  code,            ¥ mfcr  rX
  1705.     
  1706. ¥ We now get the bit we want into the low bit posn of rX.
  1707.  
  1708.     otShift&mask put: ivar> opType in GPRs
  1709.     rX_reg  >Agpr: GPRs
  1710.     field# 4*  bit# + 1+  >Blit: GPRs    ¥ rotate by one more than the bit #
  1711.                                         ¥  to get it into the low bit posn
  1712.     31 put: ivar> maskBegin in GPRs
  1713.     31 put: ivar> maskEnd   in GPRs
  1714.     compile: GPRs
  1715.  
  1716. ¥ now we have to do a negate or subtract 1.  We now target the requested gpr#,
  1717. ¥ and leave it selected at the end.  There's no problem if this is r0.
  1718.  
  1719.     gpr# select: GPRs
  1720.  
  1721.     rX_reg  >Agpr: GPRs
  1722.     1_is_true?
  1723.     IF            ¥ we need to do a negate.
  1724.         otNeg put: ivar> opType in GPRs
  1725.         noRef >Btype: GPRs
  1726.     ELSE        ¥ we need to do an addi -1.
  1727.         otAdd put: ivar> opType in GPRs
  1728.         -1 >Blit: GPRs
  1729.     THEN
  1730.     compile: GPRs
  1731.  
  1732.     debug? if
  1733.         ." cr>this_gpr used do_cr_op, leaving result in:" print: GPRs  cr dasm
  1734.     then
  1735. ;
  1736.  
  1737.  
  1738. : CR>THIS_GPR  { ^ref gpr# ¥ field# bit# 1_is_true? reg1 reg2 litval op opt? -- }
  1739.  
  1740.     debug? if
  1741.         cr ." cr>this_gpr called with:" cr
  1742.         print: [ ^ref ]
  1743.         ."  to go to gpr" gpr# . cr
  1744.         printall: cstk
  1745.     then
  1746.  
  1747.     -1 -> litval  false -> opt?
  1748.     
  1749. ¥ now, what's the bit in rX that we want?
  1750.  
  1751.     ^ref  get: ivar> field#        in class_as> reference  -> field#
  1752.     ^ref  get: ivar> bit#        in class_as> reference  -> bit#
  1753.     ^ref  get: ivar> 1_is_true?    in class_as> reference  -> 1_is_true?
  1754.  
  1755.     field# select: CRs
  1756.     free: CRs                ¥ we always want it freed, and it's safe to do
  1757.                             ¥  it now
  1758.  
  1759. ¥ we don't try to do a better optimization if the op isn't a
  1760. ¥  compare.
  1761.  
  1762.     get: ivar> opType in CRs  -> op
  1763.     op otUCMP =  op otCMP =  or
  1764.     
  1765.     IF    true -> opt?
  1766.  
  1767. ¥ which optimized sequence we use depends on what the op is, and the
  1768. ¥  exact condition we're testing for.
  1769.         Areg: CRs -> reg1
  1770.         Btype: CRs  litRef =
  1771.         IF    Blit: CRs -> litVal
  1772.             -1 -> reg2
  1773.             litval $ ffff8000 = IF  false -> opt?  THEN
  1774.                     ¥ if optimizing we sometimes negate the literal - if it's the max
  1775.                     ¥  neg 16-bit number this won't work, so as this is very unusual
  1776.                     ¥  we'll just not do the optimization in this case.
  1777.                     
  1778.             op otUCMP =  IF litval NIF  false -> opt?  THEN  THEN
  1779.                     ¥ likewise if the op is unsigned and the lit is zero, the algorithm 
  1780.                     ¥  won't work properly.  But again this is a rather bizarre case so
  1781.                     ¥  we'll just avoid it.
  1782.  
  1783.         ELSE
  1784.             Breg: CRs -> reg2
  1785.         THEN
  1786.     THEN
  1787.     
  1788.     opt?
  1789.     NIF                    ¥ we have to do it the conservative way
  1790.         gpr# field# bit# 1_is_true?  do_cr_op  EXIT
  1791.     THEN
  1792.     
  1793.     ?delete: CRs        ¥ delete the compare if it's safe to do so
  1794.  
  1795.     bit# 2 = IF  reg1 reg2 gpr# litval 1_is_true?  do_equality  EXIT  THEN
  1796.  
  1797.     reg1  reg2  bit# NIF  swap  THEN
  1798.     op otCMP =
  1799.     IF
  1800.         gpr# litval 1_is_true?  do_signed_op
  1801.     ELSE
  1802.         gpr# litval 1_is_true?  do_unsigned_op
  1803.     THEN
  1804.  
  1805. ¥    update_refcnts
  1806.     debug? if
  1807.         ." cr>this_gpr finished, leaving result in:" print: GPRs  cr dasm .al
  1808.     then
  1809. ;
  1810.  
  1811.  
  1812. ¥ CR>GPR is similar, but grabs a free GPR to use, and leaves its reference
  1813. ¥  in res1.  Frees the CR field.
  1814.  
  1815. : CR>GPR  ( ^ref -- )
  1816.     getFreeReg: GPRs  dup >gpr: res1
  1817.     cr>this_gpr
  1818. ;
  1819.  
  1820.  
  1821. ¥ __>g can be used in an inline defn to force a comparison result into
  1822. ¥  a GPR, for those situations where we know this will give better
  1823. ¥  code.
  1824.  
  1825. : __>g
  1826.     1 operands
  1827.     opnd1 push
  1828.     reftype: opnd1  crRef <>  ?EXIT        ¥ do nothing if we don't have a
  1829.                                         ¥  CR reference
  1830.     1 operands
  1831.     opnd1  cr>gpr  res1 push
  1832. ;            immediate
  1833.  
  1834.  
  1835. : PUSH_TO_MEM  { ^ref stkReg stkOffs update? ¥ refType -- }
  1836.     ^ref refType: class_as> reference
  1837.     SELECT[    gprRef    ]=>        ^ref reg: class_as> reference  select: GPRs
  1838.                             stkReg stkOffs update? compPush: GPRs
  1839.                             
  1840.           [    fprRef    ]=>        ^ref reg: class_as> reference  select: FPRs
  1841.                               stkReg stkOffs update? compPush: FPRs
  1842.  
  1843.           [    CRref    ]=>    ¥ we have to convert to a flag, since once
  1844.                           ¥  a cell is pushed to mem we don't know what
  1845.                           ¥  it is any more.
  1846.  
  1847.                               ^ref 0 cr>this_gpr        ¥ leaves r0 selected
  1848.                               stkReg stkOffs update? compPush: GPRs
  1849.  
  1850.           [    litRef    ]=>    ¥ we have to get the lit to a GPR then push it.
  1851.                           ¥ We might be doing a spill, so we won't allocate
  1852.                           ¥ a free GPR (there mightn't be one), but just
  1853.                           ¥ use r0.
  1854.                               ^ref lit: class_as> reference
  1855.                               0 select: GPRs  lit>selected_gpr
  1856.                             stkReg stkOffs update? compPush: GPRs
  1857.  
  1858.           DEFAULT=>        drop
  1859.     ]SELECT
  1860. ;
  1861.  
  1862.  
  1863. : PUSH&MOVEUP
  1864.     0 select: cstk
  1865.     refType: cstk  FPRref =
  1866.     IF
  1867.         8 --> fstk_offset
  1868.         cstk FSP_reg fstk_offset false push_to_mem
  1869.     ELSE
  1870.         1cell --> stk_offset
  1871.         cstk SP_reg stk_offset false push_to_mem
  1872.     THEN
  1873.     moveUp: cstk
  1874. ;
  1875.  
  1876.  
  1877. :f SPILL
  1878.     debug? if
  1879.         ." spilling to get a free reg" cr printall: cstk  .al
  1880.         .gs
  1881. ¥        [ ppc? not ] [if] zs [then]
  1882.     then
  1883.  
  1884. spillODs  FPRs = IF  ." FPR spill!!" cr [ ppc? ] [if] dbgr [then] then
  1885.  
  1886.     0 -> #gprs_cleared
  1887.     BEGIN
  1888.  
  1889. size: cstk 0= if
  1890. printall: cstk .al .gs cr
  1891. dasm
  1892. 1 die
  1893. then
  1894.  
  1895.         push&moveup
  1896.         #gprs_cleared spill_cnt >=
  1897.         size: cstk 0= or
  1898.     UNTIL
  1899.     debug? if
  1900.         ." after spill:" cr printall: cstk
  1901.     then
  1902. ;f
  1903.  
  1904.  
  1905. : GET_TO_REG?  { ^ref ¥ changed? -- changed? }
  1906.     false -> check_OP_stores?
  1907.     ^ref -> aRef        ¥ may be a reference_list, not a reference, but OK
  1908.     true -> check_OP_stores?
  1909.     false -> changed?
  1910.     
  1911.     refType: aRef
  1912.     SELECT[    litRef    ]=>        lit: aRef  true  lit>gpr  res1 ->: aRef
  1913.                             true -> changed?
  1914.           [    gprRef    ]=>
  1915.           [    fprRef    ]=>
  1916.           [    crRef    ]=>
  1917.           DEFAULT=>            drop
  1918.     ]SELECT
  1919.     changed?
  1920. ;
  1921.  
  1922.  
  1923. : GET_TO_GPR?  { ^ref ¥ changed? -- changed? }
  1924.     false -> check_OP_stores?
  1925.     ^ref -> aRef        ¥ may be a reference_list, not a reference, but OK
  1926.     true -> check_OP_stores?
  1927.     false -> changed?
  1928.     
  1929.     refType: aRef
  1930.     SELECT[    gprRef    ]=>            ¥ nothing to do!
  1931.                             
  1932.           [    fprRef    ]=>        to_be_written
  1933.  
  1934.           [    CRref    ]=>        aRef  cr>gpr
  1935.                               res1 ->: aRef  true -> changed?
  1936.  
  1937.           [    litRef    ]=>        lit: aRef  true  lit>gpr
  1938.                               res1 ->: aRef  true -> changed?
  1939.  
  1940.           DEFAULT=>        drop
  1941.     ]SELECT
  1942.     changed?
  1943.     debug? if
  1944.         ." get_to_gpr? leaves result in: " print: res1  cr
  1945.     then
  1946. ;
  1947.  
  1948.  
  1949. : GET_TO_THIS_GPR  { ^ref reg# -- }
  1950.     false -> check_OP_stores?
  1951.     ^ref -> aRef        ¥ may be a reference_list, not a reference, but OK
  1952.     true -> check_OP_stores?
  1953.     
  1954.     refType: aRef
  1955.     SELECT[    gprRef    ]=>        reg: aRef  reg#  true  moveReg: GPRs
  1956.                             
  1957.           [    fprRef    ]=>        to_be_written
  1958.  
  1959.           [    CRref    ]=>        aRef  reg#  cr>this_gpr
  1960.  
  1961.           [    litRef    ]=>        lit: aRef  reg#  lit>this_gpr
  1962.  
  1963.           DEFAULT=>        drop
  1964.     ]SELECT
  1965.     
  1966.     reg# >gpr: res1  res1 ->: aRef
  1967.     
  1968.     debug? if
  1969.         ." get_to_this_gpr leaves result in: " print: res1  cr
  1970.     then
  1971. ;
  1972.  
  1973.  
  1974. :f .G    select: GPRs  print: GPRs  ;f
  1975. :f .F    select: FPRs  print: FPRs  ;f
  1976. :f .C    select: CRs   print: CRs   ;f
  1977.  
  1978. :f .GS        printall: GPRs  ;f
  1979. :f .CS        printall: CRs   ;f
  1980. :f .AL        ." GPRs:" cr .allocated: GPRs  ." CRs" cr .allocated: CRs
  1981.             ." FPRs:" cr .allocated: FPRs  cr  ;f
  1982. :f .FR        .free:    GPRs  ;f
  1983. :f .FAL        ." FPRs:" cr .allocated: FPRs  ;f
  1984.  
  1985.  
  1986. : .g3
  1987.     3 select: GPRs  print: GPRs
  1988. ;
  1989.  
  1990. : .cstk
  1991.     printall: cstk  ;
  1992.  
  1993. : .cstk2
  1994.     printall: cstk2  ;
  1995.  
  1996. : .cflgs
  1997.     printall: control_flags  ;
  1998.  
  1999.  
  2000. endload
  2001.  
  2002. ¥ =========== the current test block ============
  2003.  
  2004. +echox
  2005.  
  2006. int ii
  2007.  
  2008. :f TEST { ¥ x -- }
  2009.     cr cr ." hi there one and all!" cr  1 2 3
  2010.     begin
  2011.         query cr
  2012.         begin
  2013.             rest nip 0>
  2014.         while
  2015.             defined?
  2016.             if        execute
  2017.             else
  2018.                     number
  2019.                     setup_cg
  2020.                     .al
  2021.                     get: ivar> opType in GPRs  otNOT  = .
  2022.             then
  2023.         repeat
  2024.         .s cr
  2025.     again
  2026. ;f
  2027.  
  2028. :f quit  test  ;f        ¥ temp so we can catch errors!
  2029.  
  2030.  
  2031. endload